home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / back_end / unm68gen.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  2.1 KB  |  42 lines
  1. (herald unm68gen)
  2.  
  3. ;;; we can do unsafe things here once we set the foreign call cont
  4.  
  5. (define (generate-foreign-call node)
  6.   (destructure (((cont foreign rep-list value-rep . args) (call-args node)))
  7.     (emit m68/move .l SP (reg-offset TASK task/foreign-call-cont))
  8.     (generate-push nil-reg)   ; save slink
  9.     (emit m68/move .l TASK (d@nil slink/current-task))
  10.     (iterate loop ((args (reverse args)) 
  11.                    (reps (map cadr (leaf-value rep-list))))
  12.       (cond ((null? args)
  13.              (walk (lambda (node) (kill (leaf-value node))) args))
  14.             ((eq? (car reps) 'rep/double)
  15.              (let ((reg (->register 'pointer node (leaf-value (car args)) '*)))
  16.                (emit m68/move .l (reg-offset reg 6) (@-r 15))
  17.                (emit m68/move .l (reg-offset reg 2) (@-r 15))
  18.                (loop (cdr args) (cdr reps))))
  19.             (else
  20.              (rep-push node (leaf-value (car args)) (car reps))
  21.              (loop (cdr args) (cdr reps)))))
  22.     (let ((reg (->register 'pointer node (leaf-value foreign) '*))) ; get xenoid
  23.       (emit m68/move .l (reg-offset reg 6) P))  ; P must be A0, get 2nd slot
  24.     (emit m68/jsr (@r 8))   ; a0 = P
  25.     (clear-slots)
  26.     (emit m68/move .l (reg-offset TASK task/foreign-call-cont) SP)
  27.     (emit m68/move .l (reg-offset sp -4) nil-reg)  ; restore slink
  28.     (emit m68/clr .l (reg-offset TASK task/foreign-call-cont))
  29.     (case (leaf-value value-rep)
  30.       ((rep/undefined ignore))                                        
  31.       ((rep/double)                                     ; cons a flonum
  32.        (emit m68/move .l S1 SCRATCH)                    ; save hign longword
  33.        (emit m68/move .l (machine-num 8) S1)            ; 2 words for double
  34.        (emit m68/move .l (machine-num header/double-float) AN)
  35.        (generate-slink-jump slink/make-extend)
  36.        (emit m68/move .l SCRATCH (reg-offset AN 6))
  37.        (emit m68/move .l S0 (reg-offset AN 2))
  38.        (emit m68/move .l AN A1))                         ; return consed flonum
  39.       (else
  40.        (really-rep-convert node S0 (leaf-value value-rep) A1 'rep/pointer)))
  41.     (generate-return 1)))
  42.